perm filename ACCI.F4[P11,LCS]2 blob
sn#585800 filedate 1981-05-13 generic text, type T, neo UTF8
C***** ACCI, DIAMND ***********
SUBROUTINE ACCI
COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM,JWHOLE
COMMON/DAT/RAC(69),RDT(17),XAC(7),RNTE(22),RACCI(22),NACCI(3)
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /STF/RSTFAC(0/7),RSTJ2
COMMON /FONT/JFONT /PLTR/IPLT,RHT /POSI/STFF(0/7),JJ2,POS
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY
EQUIVALENCE (R3,RJQ(1)),(J5,JQ(3)),(R5,RJQ(3))
1,(R4,RJQ(2)),(RLVL,RJQ(20)),(R6,RJQ(4))
RX=RMINI
RR3=R3
RR5=AMOD(R5,1.0)
IF(RR5.NE.0)RR3=RR3-RR5*59.6*RMINI
C TO SPACE OUT ACCIDS.
IF(JACC.GT.3)GO TO 3121
C DBL FLT(4) AND DBL SHRP(5) ALWAYS USE 'DRAW' ROUTINE.
C ADD (#) ETC.
IF(IPLT.LT.0)GO TO 3121
IF(JFONT.NE.0)GO TO 3121
NX=NACCI(JACC)
CALL RDRAW(NX+1,RACCI(NX),RACCI,RMINI,RR3,CENTR,RMINI)
RETURN
C TO DRAW GOOD ACCIS ON PLOTTER - NOT ON DPY.(IN CLEF4.DMD)
3121 RA=R3
R3=RR3
C RJZ=AMOD(R4,100.0)
J5=9
IF(JACC.LT.6)GO TO 1
C NEXT FOR (#) ETC.
R6=2.
POS=POS+21.*RMINI
RMINI=RMINI*2.0
C R3=R3-3.*RMINI
J5=99
1 J5=J5+JACC
CALL DRWNT
R3=RA
RMINI=RX
END
SUBROUTINE DIAMND
COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM,JWHOLE
COMMON /WIDTH/WID1,WID2,WIDX
COMMON/DAT/RACNT(69),RDOT(17),JXAC(7),RNOTE(22)
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /PLTR/IPLT,RHT,DIS,XDIS
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,RZTM,RXX,JJJ
EQUIVALENCE (R3,RJQ(1)),(J5,JQ(3)),(R4,RJQ(2)),(R6,RJQ(4))
1,(R7,RJQ(5)),(RX4,JQ(19)),(ISTEM,JQ(20)),(J7,JQ(5)),(J6,JQ(4))
C DIAMOND NTS=180→279
WIDX=WID1
C SET NOTE WIDTH FOR STEM ROUTINE
KL=8
RG=12.0
C FOR DIAMOND NOTES.
RB=0
IF(NTYPE.NE.3)GO TO 3
KL=13
RG=16.
RB=7.*RMINI
C THESE FOR X-NOTE =280→379
3 J4=R4
RJZ=R4
RX4=R4
IF(J6.GE.0)GO TO 1
C NOW FOR BLACK DIAMOND (J6=-1)
J6=0
J5=7
RQ=R7
RG=CENTR
2 CALL DRWNT
R7=RQ
R4=RX4
R6=0
CENTR=RG
RETURN
1 JT=1
C FOR DOUBLE-THICK X NOTES, HARMONICS.
RH=R3
1253 CALL RDRAW(KL,RG,RNOTE,RMINI,RH,CENTR,RMINI)
IF(JT.LT.0)RETURN
IF(IPLT.GE.0)RETURN
RH=RH-1.0
JT=JT-1
GO TO 1253
END